home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 090 / pctj8502.arc / TREEDIRS.PAS < prev    next >
Pascal/Delphi Source File  |  1986-09-14  |  4KB  |  159 lines
  1. { Turbo Pascal routines for tree-structured directories }
  2. { Copyright 1984 Michael A. Covington }
  3.  
  4. { Requires MS-DOS or PC-DOS 2.0 or higher, except as noted. }
  5.  
  6. { All the routines require these type definitions.          }
  7. { However, except as noted, they do not require each other. }
  8.  
  9. type pathtype  = string[63];
  10.      drivetype = string[2];
  11.      rtype     = record
  12.                    ax,bx,cx,dx,bp,si,di,ds,es,flags: integer
  13.                  end;
  14.  
  15. procedure xxdiskerr(x:drivetype);
  16. begin
  17.   writeln('Error -- Invalid disk drive, ''',x,'''');
  18.   halt
  19. end;
  20.  
  21. procedure xxpatherr(x:pathtype);
  22. begin
  23.   writeln('Error -- Invalid path, ''',x,'''');
  24.   halt
  25. end;
  26.  
  27. function currentdrive: drivetype;
  28.   { Returns designator for current default drive, e.g., 'A:'. }
  29.   { Works under DOS version 1. }
  30. var  w:   drivetype;
  31.      reg: rtype;
  32. begin
  33.   reg.ax:=$1900;
  34.   intr($21,reg);
  35.   w:='A:';
  36.   w[1]:=chr(ord(w[1])+lo(reg.ax));
  37.   currentdrive:=w
  38. end;
  39.  
  40. procedure chdrive(x:drivetype);
  41.   { Chooses a new default drive. }
  42.   { Parameter can have the form 'A:', 'A', 'a:', or 'a'.    }
  43.   { Works under DOS version 1.  Requires XXDISKERR, above.  }
  44. var  reg: rtype;
  45. begin
  46.   reg.ax := $0E00;
  47.   reg.dx := ord(upcase(x[1])) - ord('A');
  48.   intr($21,reg);
  49.   if (reg.dx < 0) or (lo(reg.ax) < lo(reg.dx)) then xxdiskerr(x);
  50. end;
  51.  
  52. function diskspace(x:drivetype): real;
  53.   { Returns number of bytes available on specified disk.   }
  54.   { Parameter as for CHDRIVE.  Requires XXDISKERR, above.  }
  55. var reg: rtype;
  56. begin
  57.   reg.ax := $3600;
  58.   reg.dx := 1 + ord(upcase(x[1])) - ord('A');
  59.   intr($21,reg);
  60.   if reg.ax = $FFFF then
  61.     xxdiskerr(x)
  62.   else
  63.     diskspace := (256.0*hi(reg.dx)+lo(reg.dx)) * reg.ax * reg.cx
  64. end;
  65.  
  66. function currentdir(x:drivetype): pathtype;
  67.   { Returns full path to active directory on specified drive, }
  68.   { including backslash at beginning, not including drive     }
  69.   { designator.  Parameter as for CHDRIVE.                    }
  70.   { Requires XXDISKERR, above.  }
  71. var  w:   pathtype;
  72.      reg: rtype;
  73.      i:   integer;
  74. begin
  75.   { Get current path }
  76.   reg.ax:=$4700;
  77.   reg.dx:=1 + ord(upcase(x[1])) - ord('A');
  78.   reg.ds:=seg(w[1]);
  79.   reg.si:=ofs(w[1]);
  80.   intr($21,reg);
  81.   if (reg.flags and 1) > 0 then xxdiskerr(x);
  82.  
  83.   { Turn it into a Turbo string }
  84.   i:=1;
  85.   while w[i]<>chr(0) do i:=i+1;
  86.   w[0]:=chr(i-1);
  87.   for i:=1 to length(w) do w[i]:=upcase(w[i]);
  88.  
  89.   currentdir := '\' + w
  90. end;
  91.  
  92. procedure xxdir(x:pathtype; k:integer);
  93.   { Executes CHDIR, MKDIR, and RMDIR requests. }
  94.   { Requires XXPATHERR and CURRENTDRIVE, above. }
  95. var w:   pathtype;
  96.     reg: rtype;
  97. begin
  98.   w := x + chr(0);
  99.   if w[2] <> ':' then  { add drive designator }
  100.     w := currentdrive + w;
  101.   reg.ax := k;
  102.   reg.ds := seg(w[1]);
  103.   reg.dx := ofs(w[1]);
  104.   intr($21,reg);
  105.   if (reg.flags and 1) > 0 then xxpatherr(x)
  106. end;
  107.  
  108. procedure chdir(x:pathtype);
  109.   { Equivalent to CHDIR command in DOS.                 }
  110.   { Requires XXDIR, XXPATHERR, and CURRENTDRIVE, above. }
  111.   { Caution!  Do not leave a directory }
  112.   { if you have files in it open.      }
  113. begin
  114.   xxdir(x,$3B00)
  115. end;
  116.  
  117. procedure rmdir(x:pathtype);
  118.   { Equivalent to RMDIR command in DOS.                 }
  119.   { Requires XXDIR, XXPATHERR, and CURRENTDRIVE, above. }
  120. begin
  121.   xxdir(x,$3A00)
  122. end;
  123.  
  124. procedure mkdir(x:pathtype);
  125.   { Equivalent to MKDIR command in DOS.                 }
  126.   { Requires XXDIR, XXPATHERR, and CURRENTDRIVE, above. }
  127. begin
  128.   xxdir(x,$3900)
  129. end;
  130.  
  131. procedure rename(x,y:pathtype);
  132.   { Renames a file; unlike the DOS RENAME command,  }
  133.   { both parameters of this command are full paths. }
  134.   { The paths need not be the same, allowing a file }
  135.   { to be moved from one directory to another.      }
  136.   { First parameter can specify a drive; any drive  }
  137.   { letter on the second parameter is ignored.      }
  138. var  wx,wy:  pathtype;
  139.      reg:    rtype;
  140. begin
  141.      wx := x + chr(0);
  142.      wy := y + chr(0);
  143.      if wx[2]<>':' then wx := currentdrive + wx;
  144.      reg.ax := $5600;
  145.      reg.ds := seg(wx[1]);
  146.      reg.dx := ofs(wx[1]);
  147.      reg.es := seg(wy[1]);
  148.      reg.di := ofs(wy[1]);
  149.      intr($21,reg);
  150.      if (reg.flags and 1) <> 0 then
  151.        begin
  152.          writeln('Error -- Invalid rename request');
  153.          writeln('      -- From: ''',x,'''');
  154.          writeln('      -- To:   ''',y,'''');
  155.          halt
  156.        end
  157. end;
  158.  
  159.